home *** CD-ROM | disk | FTP | other *** search
- ; -*- SYNTAX: ZETALISP; MODE: LISP; PACKAGE: BOXER; BASE: 10; FONTS: CPTFONT,CPTFONTB; -*-
-
- #|
- Copyright 1985 Massachusetts Institute of Technology
-
- Permission to use, copy, modify, distribute, and sell this software
- and its documentation for any purpose is hereby granted without fee,
- provided that the above copyright notice appear in all copies and that
- both that copyright notice and this permission notice appear in
- supporting documentation, and that the name of M.I.T. not be used in
- advertising or publicity pertaining to distribution of the software
- without specific, written prior permission. M.I.T. makes no
- representations about the suitability of this software for any
- purpose. It is provided "as is" without express or implied warranty.
-
-
- +-Data--+
- This file is part of the | BOXER | system
- +-------+
-
-
- This file contains basic turtle methods.
-
-
- |#
-
- (DEFVAR %LEARNING-SHAPE? NIL "This is t when doing a set-shape")
- (DEFVAR %MOUSE-USURPED NIL "Used in move-to to prevent changing boxes")
- (DEFVAR %NEW-SHAPE NIL "The new shape vectors are collected here when doing a set-shape")
- (DEFVAR %TURTLE-STATE NIL "a place to save the turtle's position, pen, and heading.
- Used primarily when doing a set-shape")
-
- ;;; Basic constructors, assessors, mutators for Turtles
- ;;; all update both the instance var and the box representation of it
- ;;; Note that several selectors have absolute versions (:absolute-x-position, for
- ;;; example). These do the calculation to get the turtle's real position from
- ;;; its relative position, in the case when it is a subsprite
-
- (DEFMETHOD (TURTLE :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR) (NEW-BOX)
- (SETQ ASSOC-GRAPHICS-BOX NEW-BOX)
- (DOLIST (SUBS SUBSPRITES)
- (TELL SUBS :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR NEW-BOX)))
-
- (DEFMETHOD (TURTLE :SET-ASSOC-GRAPHICS-BOX) (NEW-BOX)
- (WHEN (NOT-NULL ASSOC-GRAPHICS-BOX) (TELL SELF :ERASE))
- (TELL SELF :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR NEW-BOX)
- (WHEN (AND (NOT-NULL NEW-BOX)
- (TELL SELF :ABSOLUTE-SHOWN-P))
- (TELL SELF :DRAW)))
-
-
- (DEFMETHOD (TURTLE :X-POSITION) ()
- (FIRST X-POSITION))
-
- (DEFMETHOD (TURTLE :ABSOLUTE-X-POSITION) ()
- (IF SUPERIOR-TURTLE
- (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
- (SUP-XPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-X-POSITION))
- (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE)))
- (+ SUP-XPOS
- (* (COSD SUP-HEADING) (CAR X-POSITION) ABS-SIZE)
- (* (SIND SUP-HEADING) (CAR Y-POSITION) ABS-SIZE)))
- (CAR X-POSITION)))
-
- (DEFMETHOD (TURTLE :MAKE-ABSOLUTE) (XPOS YPOS)
- (IF SUPERIOR-TURTLE
- (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
- (SUP-XPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-X-POSITION))
- (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE))
- (SUP-YPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-Y-POSITION)))
- (VALUES (+ SUP-XPOS
- (* (COSD SUP-HEADING) XPOS ABS-SIZE)
- (* (SIND SUP-HEADING) YPOS ABS-SIZE))
- (+ SUP-YPOS
- (* (- (SIND SUP-HEADING)) XPOS ABS-SIZE)
- (* (COSD SUP-HEADING) YPOS ABS-SIZE))))
- (VALUES XPOS YPOS)))
-
- (DEFMETHOD (TURTLE :Y-POSITION) ()
- (FIRST Y-POSITION))
-
- (DEFMETHOD (TURTLE :ABSOLUTE-Y-POSITION) ()
- (IF SUPERIOR-TURTLE
- (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
- (SUP-YPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-Y-POSITION))
- (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE)))
- (+ SUP-YPOS
- (* (- (SIND SUP-HEADING)) (CAR X-POSITION) ABS-SIZE)
- (* (COSD SUP-HEADING) (CAR Y-POSITION) ABS-SIZE)))
- (CAR Y-POSITION)))
-
- (DEFMETHOD (TURTLE :ADD-XPOS-BOX) (BOX)
- (SETQ X-POSITION (CONS (CAR X-POSITION) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-XPOS-BOX) ()
- (SETQ X-POSITION (NCONS (CAR X-POSITION))))
-
- (DEFMETHOD (TURTLE :ADD-YPOS-BOX) (BOX)
- (SETQ Y-POSITION (CONS (CAR Y-POSITION) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-YPOS-BOX) ()
- (SETQ Y-POSITION (NCONS (CAR Y-POSITION))))
-
- (DEFMETHOD (TURTLE :SET-X-POSITION) (NEW-VALUE)
- (LET ((BOX (CDR X-POSITION)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
- (TELL BOX :MODIFIED))
- (SETF (CAR X-POSITION) NEW-VALUE)))
-
- (DEFMETHOD (TURTLE :SET-Y-POSITION) (NEW-VALUE)
- (LET ((BOX (CDR Y-POSITION)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
- (TELL BOX :MODIFIED))
- (SETF (CAR Y-POSITION) NEW-VALUE)))
-
- (DEFMETHOD (TURTLE :SET-XY) (NEW-X NEW-Y)
- (LET ((BOX (CDR X-POSITION)))
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-X)))
- (TELL BOX :MODIFIED)
- (SETF (CAR X-POSITION) NEW-X))
- (LET ((BOX (CDR Y-POSITION)))
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-Y)))
- (TELL BOX :MODIFIED)
- (SETF (CAR Y-POSITION) NEW-Y)))
-
-
- (DEFMETHOD (TURTLE :HEADING) ()
- (FIRST HEADING))
-
- (DEFMETHOD (TURTLE :ABSOLUTE-HEADING) ()
- (IF SUPERIOR-TURTLE
- (+ (CAR HEADING) (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
- (CAR HEADING)))
-
- (DEFMETHOD (TURTLE :SET-HEADING-INSTANCE-VAR) (NEW-VALUE)
- (LET ((BOX (CDR HEADING)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
- (TELL BOX :MODIFIED))
- (SETF (CAR HEADING) NEW-VALUE)))
-
- (DEFMETHOD (TURTLE :ADD-HEADING-BOX) (BOX)
- (SETQ HEADING (CONS (CAR HEADING) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-HEADING-BOX) ()
- (SETQ HEADING (NCONS (CAR HEADING))))
-
- (DEFMETHOD (TURTLE :PEN) ()
- (CAR PEN))
-
- (DEFUN GET-ALU-FROM-PEN (PEN-MODE)
- (SELECTQ PEN-MODE
- ((DOWN :DOWN BU:DOWN) TV:ALU-IOR)
- ((UP :UP BU:UP) NIL)
- ((ERASE :ERASE BU:ERASE) TV:ALU-ANDCA)
- ((XOR :XOR BU:XOR) TV:ALU-XOR)))
-
- (DEFMETHOD (TURTLE :SET-PEN) (NEW-VALUE)
- (IF %LEARNING-SHAPE? ;;; When learning shape add pen to vector list
- (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE (NCONS NEW-VALUE)))
- (LET ((BOX (CDR PEN)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
- (TELL BOX :MODIFIED))
- (SETF (CAR PEN) NEW-VALUE))))
-
-
- (DEFMETHOD (TURTLE :ADD-PEN-BOX) (BOX)
- (SETQ PEN (CONS (CAR PEN) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-PEN-BOX) ()
- (SETQ PEN (NCONS :DOWN)))
-
- (DEFMETHOD (TURTLE :SET-HOME) (NEW-X NEW-Y)
- (LET ((BOX (CDR HOME)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-X NEW-Y)))
- (TELL BOX :MODIFIED))
- (SETF (CAR HOME) (LIST NEW-X NEW-Y))))
-
- (DEFMETHOD (TURTLE :ADD-HOME-BOX) (BOX)
- (SETQ HOME (CONS (CAR HOME) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-HOME-BOX) ()
- (SETQ HOME (NCONS '(0 0))))
-
- (DEFMETHOD (TURTLE :HOME-X) ()
- (CAAR HOME))
-
- (DEFMETHOD (TURTLE :HOME-Y) ()
- (CADAR HOME))
-
- (DEFMETHOD (TURTLE :SET-SHOWN-P) (NEW-VALUE)
- (LET ((BOX (CDR SHOWN-P))
- (TOP-GUY (TELL SELF :TOP-SPRITE)))
- (TELL TOP-GUY :ERASE)
- (MULTIPLE-VALUE-BIND (WORD VALUE)
- (SELECTQ NEW-VALUE
- ((T BU:ALL BU:TRUE) (VALUES 'TRUE T))
- ((NIL BU:NONE BU:FALSE) (VALUES 'FALSE NIL))
- ((:SUBSPRITES BU:SUBSPRITES) (VALUES 'SUBSPRITES :SUBSPRITES))
- ((:NO-SUBSPRITES BU:NO-SUBSPRITES) (VALUES 'NO-SUBSPRITES ':NO-SUBSPRITES)))
- (WHEN BOX
- (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL BOX :APPEND-ROW
- (MAKE-ROW (LIST WORD)))
- (TELL BOX :MODIFIED))
- (SETQ SHOWN-P (CONS VALUE (CDR SHOWN-P)))
- (WHEN (TELL TOP-GUY :SHOWN-P)
- (TELL TOP-GUY :DRAW)))))
-
- (DEFMETHOD (TURTLE :SHOWN-P-SYMBOL) ()
- (SELECTQ (CAR SHOWN-P)
- ((NIL) 'FALSE)
- ((:SUBSPRITES) 'SUBSPRITES)
- ((:NO-SUBSPRITES) 'NO-SUBSPRITES)
- (T 'TRUE)))
-
- (DEFMETHOD (TURTLE :TOP-SPRITE) ()
- (IF SUPERIOR-TURTLE
- (TELL SUPERIOR-TURTLE :TOP-SPRITE)
- SELF))
-
- (DEFMETHOD (TURTLE :SHOWN-P) ()
- (NOT (NOT (CAR SHOWN-P))))
-
- (DEFMETHOD (TURTLE :SUBSPRITES-SHOWN-P) ()
- (IF SUPERIOR-TURTLE
- (AND (TELL SUPERIOR-TURTLE :SUBSPRITES-SHOWN-P)
- (MEMQ (CAR SHOWN-P) '(T :SUBSPRITES)))
- (MEMQ (CAR SHOWN-P) '(T :SUBSPRITES))))
-
-
- (DEFMETHOD (TURTLE :ABSOLUTE-SHOWN-P) ()
- (LET ((SH (CAR SHOWN-P)))
- (IF SUPERIOR-TURTLE
- (IF (NULL SH)
- NIL
- (TELL SUPERIOR-TURTLE :SUBSPRITES-SHOWN-P))
- (NOT (NOT SH)))))
-
- (DEFMETHOD (TURTLE :ADD-SHOWN-P-BOX) (BOX)
- (SETQ SHOWN-P (CONS (CAR SHOWN-P) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-SHOWN-P-BOX) ()
- (SETQ SHOWN-P (NCONS (CAR SHOWN-P)))
- (TELL SELF :SET-SHOWN-P T))
-
- (DEFMETHOD (TURTLE :SET-SIZE) (NEW-SIZE)
- (IF (<= NEW-SIZE 0)
- (FERROR "Argument to Set-size, ~d , was less than or equal to zero" NEW-SIZE)
- (TELL SELF :ERASE)
- (LET ((BOX (CDR SIZE)))
- (TELL-CHECK-NIL BOX :SET-FIRST-INFERIOR-ROW NIL)
- (TELL-CHECK-NIL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-SIZE)))
- (TELL-CHECK-NIL BOX :MODIFIED)
- (SETF (CAR SIZE) NEW-SIZE))
- (TELL SELF :DRAW)))
-
- (DEFMETHOD (TURTLE :ABSOLUTE-SIZE) ()
- (IF SUPERIOR-TURTLE
- (* (CAR SIZE) (TELL SUPERIOR-TURTLE :ABSOLUTE-SIZE))
- (CAR SIZE)))
-
- (DEFMETHOD (TURTLE :SIZE) ()
- (CAR SIZE))
-
- (DEFMETHOD (TURTLE :ADD-SIZE-BOX) (BOX)
- (SETQ SIZE (CONS (CAR SIZE) BOX)))
-
-
- (DEFMETHOD (TURTLE :REMOVE-SIZE-BOX) ()
- (SETQ SIZE (NCONS (CAR SIZE)))
- (TELL SELF :SET-SIZE 1))
-
- (DEFMETHOD (TURTLE :SHAPE) ()
- (CAR SHAPE))
-
- (DEFMETHOD (TURTLE :ADD-SHAPE-BOX) (BOX)
- (SETQ SHAPE (CONS (CAR SHAPE) BOX)))
-
- (DEFMETHOD (TURTLE :REMOVE-SHAPE-BOX) ()
- (TELL SELF :ERASE)
- (SETQ SHAPE (LIST *TURTLE-SHAPE*))
- (TELL SELF :DRAW))
-
- (DEFMETHOD (TURTLE :ADD-SUBTURTLE) (SUBTURTLE)
- (TELL SUBTURTLE :SET-SUPERIOR-TURTLE SELF)
- (TELL SUBTURTLE :SET-ASSOC-GRAPHICS-BOX ASSOC-GRAPHICS-BOX)
- (SETQ SUBSPRITES (CONS SUBTURTLE SUBSPRITES)))
-
- (DEFMETHOD (TURTLE :REMOVE-SUBTURTLE) (SUBTURTLE)
- (TELL SUBTURTLE :SET-ASSOC-GRAPHICS-BOX NIL)
- (TELL SUBTURTLE :SET-SUPERIOR-TURTLE NIL)
- (SETQ SUBSPRITES (DELQ SUBTURTLE SUBSPRITES)))
-
- ; The higher level stuff.
-
- ;;; ALL TURTLE functions are assumed to be called in an environment where the various
- ;;; turtle state variables as well as GRAPHICS vars (like BIT-ARRAY) are BOUND.
- ;;; This is what the MACRO WITH-TURTLE-VARS-BOUND is used for.
- ;;; The three main entry points into turtle graphics are the messages...
- ;;; :MOVE-TO
- ;;; :TURN-TO and
- ;;; :DRAW
- ;;; These three methods have WHOPPERS with the proper macro wrapped around them...
- ;;; All other turtle functions that do things to the screen should be built out of these or
- ;;; at least use the macro so that things get drawn in the right place
-
-
-
- ;;;ED -- If you look at the stack during the execution of any sprite command,
- ;;;macros are nested many times. For example the draw whopper gets called for
- ;;;drawing each subsprite of a sprite. If that sprite moved, the move-to whopper would
- ;;;be called too. Someone should probably clean this up so that these whoppers get
- ;;; called only once for each turtle command.
-
- (DEFWHOPPER (TURTLE :MOVE-TO) (&REST ARGS)
- (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
- (LEXPR-CONTINUE-WHOPPER ARGS)))
-
- (DEFWHOPPER (TURTLE :TURN-TO) (NEW-HEADING)
- (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
- (CONTINUE-WHOPPER NEW-HEADING)))
-
- (DEFWHOPPER (TURTLE :DRAW) (&REST ARGS)
- (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
- (LEXPR-CONTINUE-WHOPPER ARGS)))
-
- ;;; Drawing the turtle...
-
- (DEFMETHOD (TURTLE :DRAW) (&OPTIONAL (ALU TV:ALU-XOR))
- (UNLESS (EQ (CAR SHOWN-P) :SUBSPRITES)
- (DRAW-VECTOR-LIST
- (CAR SHAPE)
- (TELL SELF :ABSOLUTE-SIZE)
- (ARRAY-COORDINATE-X (TELL SELF :ABSOLUTE-X-POSITION))
- (ARRAY-COORDINATE-Y (TELL SELF :ABSOLUTE-Y-POSITION))
- (TELL SELF :ABSOLUTE-HEADING)
- ALU))
- (UNLESS (EQ (CAR SHOWN-P) :NO-SUBSPRITES)
- (DOLIST (SUBS SUBSPRITES)
- (TELL SUBS :DRAW)))
- (TELL ASSOC-GRAPHICS-BOX :MODIFIED))
-
- (DEFMETHOD (TURTLE :ERASE) ()
- (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
-
- (DEFMETHOD (TURTLE :SHOW-TURTLE) ()
- (TELL SELF :SET-SHOWN-P T))
-
- (DEFMETHOD (TURTLE :HIDE-TURTLE) ()
- (TELL SELF :SET-SHOWN-P NIL))
-
- ;;; Moving around
-
- (DEFMETHOD (TURTLE :MOVE-TO) (X-DEST Y-DEST)
- (IF (NOT (AND (NUMBERP X-DEST) (NUMBERP Y-DEST)))
- (FERROR "one of the args, ~s or ~s, was not a number" X-DEST Y-DEST)
- (COND (%LEARNING-SHAPE? ;;; don't draw while learning shape.
- (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE
- (LIST (- X-DEST (CAR X-POSITION))
- (- (CAR Y-POSITION) Y-DEST))))
- ;;; While in learning-shape, don't update any boxes
- (SETF (CAR X-POSITION) X-DEST)
- (SETF (CAR Y-POSITION) Y-DEST))
- ; Have to make fence mode work some other time
- ; ((and (eq %draw-mode ':fence)
- ; (not (point-in-array? array-x-dest array-y-dest)))
- ; (ferror "you hit the fence"))
- (T
- (MULTIPLE-VALUE-BIND (ARRAY-X-DEST ARRAY-Y-DEST)
- (TELL SELF :MAKE-ABSOLUTE X-DEST Y-DEST)
- (SETQ ARRAY-X-DEST (FIX-ARRAY-COORDINATE-X ARRAY-X-DEST)
- ARRAY-Y-DEST (FIX-ARRAY-COORDINATE-Y ARRAY-Y-DEST))
- (LET ((ARRAY-X (FIX-ARRAY-COORDINATE-X (TELL SELF :ABSOLUTE-X-POSITION)))
- (ARRAY-Y (FIX-ARRAY-COORDINATE-Y (TELL SELF :ABSOLUTE-Y-POSITION)))
- (PEN-ALU (GET-ALU-FROM-PEN (CAR PEN))))
- (WITHOUT-INTERRUPTS
- (WHEN (AND (NULL SUPERIOR-TURTLE) (EQ %DRAW-MODE ':WRAP))
- (SETQ X-DEST (WRAP-X-COORDINATE X-DEST)
- Y-DEST (WRAP-Y-COORDINATE Y-DEST)))
- (TELL SELF :ERASE)
- (IF %MOUSE-USURPED
- ;;; don't update boxes during follow-mouse
- (PROGN (SETF (CAR X-POSITION) X-DEST)
- (SETF (CAR Y-POSITION) Y-DEST))
- (TELL SELF :SET-XY X-DEST Y-DEST))
- (WHEN PEN-ALU
- (CK-MODE-DRAW-LINE ARRAY-X ARRAY-Y
- ARRAY-X-DEST ARRAY-Y-DEST
- PEN-ALU)))
- (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW))
- (TELL %GRAPHICS-BOX :MODIFIED)))))))
-
-
- (DEFMETHOD (TURTLE :FORWARD) (DISTANCE)
- (LET* ((HEAD (CAR HEADING))
- (CHANGE-X (* DISTANCE (SIND HEAD)))
- (CHANGE-Y (* DISTANCE (COSD HEAD))))
- (TELL SELF :MOVE-TO
- (+ CHANGE-X (CAR X-POSITION)) (+ CHANGE-Y (CAR Y-POSITION)))))
-
- (DEFMETHOD (TURTLE :GO-HOME) ()
- (TELL SELF :MOVE-TO (CAAR HOME) (CADAR HOME))
- (TELL SELF :TURN-TO 0))
-
- ;;; Turning around
- (DEFMETHOD (TURTLE :TURN-TO) (NEW-HEADING)
- (COND ((NUMBERP NEW-HEADING)
- (IF %LEARNING-SHAPE?
- (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360))
- (WITHOUT-INTERRUPTS
- (TELL SELF :ERASE)
- (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360))
- (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW))
- (TELL %GRAPHICS-BOX :MODIFIED))))
- (T (FERROR "the argument, ~s, was not a number" NEW-HEADING))))
-
- (DEFMETHOD (TURTLE :RIGHT) (DEGREES)
- (TELL SELF :TURN-TO (+ (CAR HEADING) DEGREES)))
-
- (DEFMETHOD (TURTLE :TURN-TO-WITHOUT-DRAW) (NEW-HEADING)
- (COND ((NUMBERP NEW-HEADING)
- (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360)))
- (T (FERROR "the argument, ~s, was not a number" NEW-HEADING))))
-
- (DEFMETHOD (TURTLE :ROTATE) (DEGREES)
- (TELL SELF :ERASE)
- (DOLIST (SUBS SUBSPRITES)
- (TELL SUBS :TURN-TO-WITHOUT-DRAW (- (TELL SUBS :HEADING) DEGREES)))
- (TELL SELF :TURN-TO-WITHOUT-DRAW (+ (CAR HEADING) DEGREES))
- (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
-
- ;;; stupidly returns degrees needed to turn right instead of heading to turn towards
- ;(DEFMETHOD (TURTLE :TOWARDS) (X Y)
- ; (COND ((AND (< (ABS (- X (CAR X-POSITION))) .0001) (> Y (CAR Y-POSITION)))
- ; (- 360. (CAR HEADING)))
- ; ((< (ABS (- X (CAR X-POSITION))) .0001)
- ; (FLOAT-MODULO (+ (- 360 (CAR HEADING)) 180.) 360.))
- ; (T (FLOAT-MODULO (+ (- 360 (CAR HEADING))
- ; (// (* 180. (ATAN (- X (CAR X-POSITION))
- ; (- Y (CAR Y-POSITION)))) )) 360.))))
- (DEFMETHOD (TURTLE :TOWARDS) (X Y)
- (COND ((AND (< (ABS (- X (CAR X-POSITION))) .0001) (> Y (CAR Y-POSITION)))
- 0)
- ((< (ABS (- X (CAR X-POSITION))) .0001)
- 180.)
- (T (FLOAT-MODULO (// (* 180. (ATAN (- X (CAR X-POSITION))
- (- Y (CAR Y-POSITION)))) ) 360.))))
-
- (DEFMETHOD (TURTLE :SET-HEADING) (NEW-HEADING)
- (TELL SELF :TURN-TO NEW-HEADING))
-
- ;;; changing shape
-
- (DEFMETHOD (TURTLE :SAVE-STATE-AND-RESET) ()
- (SETQ %TURTLE-STATE
- (LIST (CAR X-POSITION) (CAR Y-POSITION) (CAR HEADING)))
- (TELL SELF :SET-X-POSITION 0)
- (TELL SELF :SET-Y-POSITION 0)
- (TELL SELF :SET-HEADING 0))
-
- (DEFMETHOD (TURTLE :RESTORE-STATE) ()
- (TELL SELF :SET-X-POSITION (FIRST %TURTLE-STATE))
- (TELL SELF :SET-Y-POSITION (SECOND %TURTLE-STATE))
- (TELL SELF :SET-HEADING (THIRD %TURTLE-STATE)))
-
- (DEFMETHOD (TURTLE :SET-SHAPE-FROM-BOX) (BOX)
- (LET ((%LEARNING-SHAPE? T) (%NEW-SHAPE NIL))
- (TELL SELF :SAVE-STATE-AND-RESET)
- (if (send box :superior? sprite-box)
- (BOXER-TELLING BOX BOX)
- (BOXER-TELLING BOX SPRITE-BOX))
- (TELL SELF :SET-PEN :UP)
- (TELL SELF :MOVE-TO 0 0)
- (TELL SELF :RESTORE-STATE)
- (TELL SELF :ERASE)
- (SETQ SHAPE (NCONS %NEW-SHAPE))
- ; (tell-check-nil (cdr shape) :set-contents-from-stream
- ; (make-box-stream box))
- ; (tell-check-nil (cdr shape) :modified)
- (when (tell self :shown-p) (TELL SELF :DRAW))
- ))
-
- ;;; Stuff for mouse-sensitivity
-
- (DEFMETHOD (TURTLE :ENCLOSING-RECTANGLE) ()
- (LET* ((XPOS (TELL SELF :ABSOLUTE-X-POSITION))
- (YPOS (TELL SELF :ABSOLUTE-Y-POSITION))
- (ABS-HEAD (TELL SELF :ABSOLUTE-HEADING))
- (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE))
- (LEFT XPOS)
- (RIGHT XPOS)
- (TOP YPOS)
- (BOTTOM YPOS))
- (UNLESS (EQ (CAR SHOWN-P) :SUBSPRITES)
- (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
- (CALC-RECTANGLE XPOS YPOS XPOS YPOS
- (CAR SHAPE) XPOS YPOS
- (* ABS-SIZE (COSD ABS-HEAD))
- (* ABS-SIZE (SIND ABS-HEAD)))))
- (UNLESS (EQ (CAR SHOWN-P) :NO-SUBSPRITES)
- (DOLIST (SUBS SUBSPRITES)
- (WHEN (TELL SUBS :ABSOLUTE-SHOWN-P)
- (MULTIPLE-VALUE-BIND (SUB-LEFT SUB-TOP SUB-RIGHT SUB-BOTTOM)
- (TELL SUBS :ENCLOSING-RECTANGLE)
- (SETQ LEFT (MIN LEFT SUB-LEFT)
- TOP (MAX TOP SUB-TOP)
- RIGHT (MAX RIGHT SUB-RIGHT)
- BOTTOM (MIN BOTTOM SUB-BOTTOM))))))
- (VALUES LEFT TOP RIGHT BOTTOM)))
-
- (DEFUN CALC-RECTANGLE (LEFT TOP RIGHT BOTTOM SHAPE X-POS Y-POS COS-HEAD SIN-HEAD)
- (COND ((NULL SHAPE) (VALUES LEFT TOP RIGHT BOTTOM))
- ((STRINGP (FIRST SHAPE))
- (LET ((STRING-RIGHT 0) (STRING-BOTTOM 0))
- (DO* ((STRING (SUBSTRING (FIRST SHAPE) 0 (OR(STRING-SEARCH-CHAR #\CR (FIRST SHAPE))
- (STRING-LENGTH (FIRST SHAPE))))
- (SUBSTRING RSTRING 0 (OR (STRING-SEARCH-CHAR #\CR RSTRING)
- (STRING-LENGTH RSTRING))))
- (RSTRING (SUBSTRING (FIRST SHAPE)
- (OR (AND (STRING-SEARCH-CHAR #\CR (FIRST SHAPE))
- (1+ (STRING-SEARCH-CHAR #\CR (FIRST SHAPE))))
- (STRING-LENGTH (FIRST SHAPE)))
- (STRING-LENGTH (FIRST SHAPE)))
- (SUBSTRING RSTRING
- (OR (AND (STRING-SEARCH-CHAR #\CR RSTRING)
- (1+ (STRING-SEARCH-CHAR #\CR RSTRING)))
- (STRING-LENGTH RSTRING))
- (STRING-LENGTH RSTRING))))
- ((STRING-EQUAL STRING ""))
- (SETQ STRING-RIGHT
- (MAX STRING-RIGHT (* *FONT-WIDTH*
- (STRING-LENGTH STRING)))
- STRING-BOTTOM (- STRING-BOTTOM *FONT-HEIGHT* 2)))
- (CALC-RECTANGLE LEFT TOP
- (MAX RIGHT (+ X-POS 3. STRING-RIGHT))
- (MIN BOTTOM (+ Y-POS 1. STRING-BOTTOM))
- (CDR SHAPE) X-POS Y-POS COS-HEAD SIN-HEAD)))
- ((NUMBERP (FIRST SHAPE))
- (LET ((NEW-X (+ X-POS
- (* (FIRST SHAPE) COS-HEAD)
- (* (SECOND SHAPE) (- SIN-HEAD))))
- (NEW-Y (+ Y-POS
- (* (FIRST SHAPE) (- SIN-HEAD))
- (* (SECOND SHAPE) (- COS-HEAD)))))
- (CALC-RECTANGLE (MIN LEFT NEW-X) (MAX TOP NEW-Y)
- (MAX RIGHT NEW-X) (MIN BOTTOM NEW-Y)
- (CDDR SHAPE) NEW-X NEW-Y COS-HEAD SIN-HEAD)))
- (T (CALC-RECTANGLE LEFT TOP RIGHT BOTTOM (CDR SHAPE)
- X-POS Y-POS COS-HEAD SIN-HEAD))))
-
- (DEFMETHOD (TURTLE :TOUCHING?) (OTHER-TURTLE)
- (MULTIPLE-VALUE-BIND (LEFT1 TOP1 RIGHT1 BOTTOM1)
- (TELL SELF :ENCLOSING-RECTANGLE)
- (MULTIPLE-VALUE-BIND (LEFT2 TOP2 RIGHT2 BOTTOM2)
- (TELL OTHER-TURTLE :ENCLOSING-RECTANGLE)
- ;;; Check an edge at a time
- (OR (AND (INCLUSIVE-BETWEEN? LEFT1 LEFT2 RIGHT2)
- (OR (AND (>= TOP1 TOP2) (<= BOTTOM1 TOP2))
- (AND (>= TOP1 BOTTOM2) (<= BOTTOM1 BOTTOM2))))
- (AND (INCLUSIVE-BETWEEN? RIGHT1 LEFT2 RIGHT2)
- (OR (AND (>= TOP1 TOP2) (<= BOTTOM1 TOP2))
- (AND (>= TOP1 BOTTOM2) (<= BOTTOM1 BOTTOM2))))
- (AND (INCLUSIVE-BETWEEN? TOP1 TOP2 BOTTOM2)
- (OR (AND (>= RIGHT1 RIGHT2) (<= LEFT1 RIGHT2))
- (AND (>= RIGHT1 LEFT2) (<= LEFT1 LEFT2))))
- (AND (INCLUSIVE-BETWEEN? BOTTOM1 TOP2 BOTTOM2)
- (OR (AND (>= RIGHT1 RIGHT2) (<= LEFT1 RIGHT2))
- (AND (>= RIGHT1 LEFT2) (<= LEFT1 LEFT2))))
- ;; Finally check a single point in each
- (AND (INCLUSIVE-BETWEEN? LEFT2 LEFT1 RIGHT1)
- (INCLUSIVE-BETWEEN? TOP2 TOP1 BOTTOM1))
- (AND (INCLUSIVE-BETWEEN? LEFT1 LEFT2 RIGHT2)
- (INCLUSIVE-BETWEEN? TOP1 TOP2 BOTTOM2))))))
-
- (DEFMETHOD (TURTLE :SPRITE-UNDER) ()
- (LET ((OBJECTS (TELL ASSOC-GRAPHICS-BOX :OBJECT-LIST)))
- (SETQ OBJECTS (DELQ (TELL SELF :TOP-SPRITE) (COPYLIST OBJECTS)))
- (FIND-SPRITE-UNDER-POINT (TELL SELF :ABSOLUTE-X-POSITION)
- (TELL SELF :ABSOLUTE-Y-POSITION)
- OBJECTS)))
-
- (DEFMETHOD (TURTLE :ALL-SPRITES-IN-CONTACT) ()
- (LET ((OBJECTS (TELL ASSOC-GRAPHICS-BOX :OBJECT-LIST))
- TURTLES)
- (SETQ OBJECTS (DELQ (TELL SELF :TOP-SPRITE) (COPYLIST OBJECTS)))
- (DOLIST (OBJECT OBJECTS)
- (WHEN (TELL SELF :TOUCHING? OBJECT)
- (SETQ TURTLES (CONS OBJECT TURTLES))))
- TURTLES))
-
- (DEFUN CALC-NAME-POSITION-X (LENGTH LEFT RIGHT)
- (SETQ LEFT (ARRAY-COORDINATE-X LEFT)
- RIGHT (ARRAY-COORDINATE-X RIGHT))
- (IF (> (+ RIGHT LENGTH) %DRAWING-WIDTH)
- (FIXR (- LEFT LENGTH 3.))
- (FIXR (+ RIGHT 5.))))
-
- (DEFUN CALC-NAME-POSITION-Y (HEIGHT TOP BOTTOM)
- (LET ((CENTER (+ (ARRAY-COORDINATE-Y TOP)
- (// (- TOP BOTTOM) 2))))
- (FIXR (MIN (MAX CENTER 0)
- (- %DRAWING-HEIGHT HEIGHT 1.)))))
-
- ;;; Drawing the turtle's name
-
- (DEFMETHOD (TURTLE :FLASH-NAME) ()
- (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
- (LET* ((PRINT-NAME (TELL SPRITE-BOX :NAME))
- (NAME-LENGTH (* *FONT-WIDTH* (STRING-LENGTH PRINT-NAME))))
- (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
- (TELL SELF :ENCLOSING-RECTANGLE)
- (LET ((X-POS (CALC-NAME-POSITION-X NAME-LENGTH LEFT RIGHT))
- (Y-POS (CALC-NAME-POSITION-Y *FONT-HEIGHT* TOP BOTTOM)))
- (DRAW-STRING-TO-GBOX PRINT-NAME X-POS Y-POS)
- (PROCESS-SLEEP 120 "Pausing to flash name")
- (DRAW-STRING-TO-GBOX PRINT-NAME X-POS Y-POS))))))
-
- (DEFUN PENUP? (PEN-MODE)
- (MEMQ PEN-MODE '(UP :UP BU:UP)))
-
- (DEFMETHOD (TURTLE :TYPE-BOX) (BOX)
- (IF %LEARNING-SHAPE?
- (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE (NCONS (TEXT-STRING BOX))))
- (UNLESS (PENUP? (CAR PEN))
- (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
- (LET ((XPOS (+ 3. (FIX-ARRAY-COORDINATE-X (CAR X-POSITION))))
- (YPOS (1+ (FIX-ARRAY-COORDINATE-Y (CAR Y-POSITION)))))
- (DRAW-STRING-TO-GBOX (TEXT-STRING BOX) XPOS YPOS (GET-ALU-FROM-PEN (CAR PEN))))))))
-
- ;;; Following the mouse (Drawing with the mouse)
-
-
- (DEFMETHOD (TURTLE :USURP-MOUSE) (&AUX OLD-X OLD-Y)
- (IF (GRAPHICS-BOX? ASSOC-GRAPHICS-BOX)
- (UNWIND-PROTECT
- (LET ((%MOUSE-USURPED T))
- (TV:WITH-MOUSE-USURPED
- (TAGBODY
- (SETQ OLD-X TV:MOUSE-X OLD-Y TV:MOUSE-Y)
- (SETQ TV:WHO-LINE-MOUSE-GRABBED-DOCUMENTATION "Sprite grabbed the mouse")
- (TELL *POINT-BLINKER* :SET-VISIBILITY NIL)
- (TELL TV:MOUSE-BLINKER :SET-VISIBILITY NIL)
- LOOP
- (MULTIPLE-VALUE-BIND (DELTA-X DELTA-Y PRESSED-BUTTONS IGNORE)
- (TV:MOUSE-INPUT)
- (TELL SELF :MOVE-TO
- (+ (CAR X-POSITION) (// DELTA-X 2))
- (- (CAR Y-POSITION) (// DELTA-Y 2)))
- (WHEN (= 0 PRESSED-BUTTONS) (GO LOOP))))))
- (SETQ TV:MOUSE-X OLD-X TV:MOUSE-Y OLD-Y)
- (TELL SELF :SET-XY (CAR X-POSITION) (CAR Y-POSITION))
- (TELL *POINT-BLINKER* :SET-VISIBILITY :BLINK))
- (FERROR "Follow-mouse can only be called when the graphics box is showing")))
-
- (DEFMETHOD (TURTLE :USURP-MOUSE-WAITING-FOR-BUTTON-RAISE) (&AUX OLD-X OLD-Y)
- (IF (GRAPHICS-BOX? ASSOC-GRAPHICS-BOX)
- (UNWIND-PROTECT
- (LET ((%MOUSE-USURPED T))
- (TV:WITH-MOUSE-USURPED
- (TAGBODY
- (SETQ OLD-X TV:MOUSE-X OLD-Y TV:MOUSE-Y)
- (SETQ TV:WHO-LINE-MOUSE-GRABBED-DOCUMENTATION "Sprite grabbed the mouse")
- (TELL *POINT-BLINKER* :SET-VISIBILITY NIL)
- (TELL TV:MOUSE-BLINKER :SET-VISIBILITY NIL)
- LOOP
- (MULTIPLE-VALUE-BIND (DELTA-X DELTA-Y IGNORE RAISED-BUTTON IGNORE)
- (TV:MOUSE-INPUT)
- (TELL SELF :MOVE-TO
- (+ (CAR X-POSITION) (// DELTA-X 2))
- (- (CAR Y-POSITION) (// DELTA-Y 2)))
- (WHEN (= 0 RAISED-BUTTON) (GO LOOP))))))
- (SETQ TV:MOUSE-X OLD-X TV:MOUSE-Y OLD-Y)
- (TELL SELF :SET-XY (CAR X-POSITION) (CAR Y-POSITION))
- (TELL *POINT-BLINKER* :SET-VISIBILITY :BLINK))
- (FERROR "Follow-mouse can only be called when the graphics box is showing")))
-
- (DEFMETHOD (TURTLE :STAMP) ()
- (TELL SELF :ERASE)
- (LET ((PEN-MODE (GET-ALU-FROM-PEN (CAR PEN))))
- (WHEN PEN-MODE
- (TELL SELF :DRAW PEN-MODE)))
- (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
-
- (DEFMETHOD (TURTLE :COPY-SELF) ()
- (TELL SPRITE-BOX :COPY))
-